home *** CD-ROM | disk | FTP | other *** search
Text File | 1994-05-31 | 10.8 KB | 330 lines | [TEXT/EMAC] |
- ;;;
- ;;; Code to send Apple events to Think C
- ;;;
-
- ;;; Used when sending kRun events
- (defvar tc:use-debugger nil)
-
- ;;; Used when sending kMake events
- (defvar tc:quick-scan t "*When nil, turn off quick scan for Make.")
-
- (defmacro create-think-c-apple-event (eventClass eventID event transactionID)
- (list 'ae-create-apple-event "KAHL" eventClass eventID event transactionID))
-
- (defun tc:send-event (event)
- (let* ((reply (make-string sizeof-AppleEvent 0))
- (err (AESend event reply (+ kAEQueueReply kAENeverInteract)
- kAENormalPriority 0 0 0)))
- (if (not (zerop err))
- err
- reply)))
-
- (defun tc:open-file (file)
- (let* (event
- (reply (make-string sizeof-AppleEvent 0))
- spec
- transactionID
- (result
- (catch 'panic
- (throw-err (create-think-c-apple-event kCoreEventClass kAEOpenDocuments
- event transactionID))
- (throw-err (unix-filename-to-FSSpec file spec))
- (throw-err (AEPutParamPtr event keyDirectObject typeFSS spec (length spec)))
- (throw-err (AESend event reply (+ kAENoReply kAENeverInteract)
- kAENormalPriority 0 0 0))
- noErr)))
- (if event (AEDisposeDesc event))
- result))
-
- (defun tc:run ()
- (let* (event
- (reply (make-string sizeof-AppleEvent 0))
- transactionID
- (result
- (catch 'panic
- (throw-err (create-think-c-apple-event kAEThinkSuite kAERun
- event transactionID))
- (throw-err (AEPutParamPtr event keyUpdateOptions typeEnumerated kAEYes 4))
- (throw-err (AEPutParamPtr event keyAESaveOptions typeEnumerated kAEYes 4))
- (throw-err (AEPutParamPtr event keyUseDebugger typeBoolean
- (make-string 1 (if tc:use-debugger 1 0)) 1))
- (throw-err (AEPutParamPtr event keyGo typeBoolean (make-string 1 1) 1))
- (throw-err (AESend event reply (+ kAEQueueReply kAENeverInteract)
- kAENormalPriority 0 0 0))
- (setq ae-history (cons (cons transactionID
- (list (cons 'description "run")
- (cons 'handler 'do-simple-reply)))
- ae-history))
- noErr)))
-
- (if event (AEDisposeDesc event))
- result))
-
- (defun tc:open-project (file)
- (let* (event
- spec
- (reply (make-string sizeof-AppleEvent 0))
- actualSize
- transactionID
- (result
- (catch 'panic
- (throw-err (create-think-c-apple-event kCoreEventClass kAEOpen
- event transactionID))
- (throw-err (unix-filename-to-FSSpec file spec))
- (throw-err (AEPutParamPtr event keyDirectObject typeFSS spec (length spec)))
- (throw-err (AESend event reply (+ kAEQueueReply kAENeverInteract)
- kAENormalPriority 0 0 0))
- (setq ae-history
- (cons (cons transactionID
- (list (cons 'description (concat "open-project " file))
- (cons 'handler 'do-simple-reply)))
- ae-history))
- noErr)))
-
- (if event (AEDisposeDesc event))
- result))
-
- (defun tc:close-project ()
- (let* ((null-desc (make-string sizeof-AEDesc 0))
- have-null-desc
- (proj-desc (make-string sizeof-AEDesc 0))
- have-proj-desc
- (proj-obj (make-string sizeof-AEDesc 0))
- have-proj-obj
- event
- (reply (make-string sizeof-AppleEvent 0))
- actualSize
- transactionID
- (one (encode-long-integer 1))
- (result
- (catch 'panic
- (throw-err (create-think-c-apple-event kCoreEventClass kAEClose
- event transactionID))
- (throw-err (AECreateDesc typeNull "" 0 null-desc))
- (setq have-null-desc t)
- (throw-err (AECreateDesc typeLongInteger one (length one) proj-desc))
- (setq have-proj-desc t)
- (throw-err (CreateObjSpecifier cProjectDocument null-desc formAbsolutePosition
- proj-desc 0 proj-obj))
- (setq have-proj-obj t)
- (throw-err (AEPutParamDesc event keyDirectObject proj-obj))
-
- (throw-err (AESend event reply (+ kAEQueueReply kAENeverInteract)
- kAENormalPriority 0 0 0))
-
- (setq ae-history
- (cons (cons transactionID (list (cons 'description "close-project")
- (cons 'handler 'do-simple-reply)))
- ae-history))
- noErr)))
-
- (if have-null-desc (AEDisposeDesc null-desc))
- (if have-proj-desc (AEDisposeDesc proj-desc))
- (if have-proj-obj (AEDisposeDesc proj-obj))
- (if event (AEDisposeDesc event))
- result))
-
- (defun tc:build-application (appname)
- (let* ((null-desc (make-string sizeof-AEDesc 0))
- have-null-desc
- (proj-obj (make-string sizeof-AEDesc 0))
- have-proj-obj
- (proj-desc (make-string sizeof-AEDesc 0))
- have-proj-desc
- event
- (reply (make-string sizeof-AppleEvent 0))
- actualSize
- transactionID
- spec
- (one (encode-long-integer 1))
- (result
- (catch 'panic
- (throw-err (create-think-c-apple-event kAECoreSuite kAESave
- event transactionID))
-
- (throw-err (AECreateDesc typeNull "" 0 null-desc))
- (setq have-null-desc t)
- (throw-err (AECreateDesc typeLongInteger one (length one) proj-desc))
- (setq have-proj-desc t)
- (throw-err (CreateObjSpecifier cProjectDocument null-desc formAbsolutePosition
- proj-desc 0 proj-obj))
- (setq have-proj-obj t)
- (throw-err (AEPutParamDesc event keyDirectObject proj-obj))
-
- (let ((err (unix-filename-to-FSSpec appname spec)))
- (if (and (not (zerop err)) (not (= err fnfErr))) (throw 'panic err)))
- (throw-err (AEPutParamPtr event keyAEFile typeFSS spec (length spec)))
- (throw-err (AEPutParamPtr event keyAEFileType typeType kProjectType 4))
- (throw-err (AEPutParamPtr event keySaveFlags typeLongInteger one (length one)))
-
- (throw-err (AESend event reply (+ kAEQueueReply kAENeverInteract)
- kAENormalPriority 0 0 0))
-
- (setq ae-history
- (cons (cons transactionID
- (list (cons 'description (concat "build-application " appname))
- (cons 'handler 'tc:do-build-reply)))
- ae-history))
- noErr)))
-
- (if have-null-desc (AEDisposeDesc null-desc))
- (if have-proj-desc (AEDisposeDesc proj-desc))
- (if have-proj-obj (AEDisposeDesc proj-obj))
- (if event (AEDisposeDesc event))
- result))
-
- (defun tc:make ()
- (let* ((null-desc (make-string sizeof-AEDesc 0))
- have-null-desc
- (file-desc (make-string sizeof-AEDesc 0))
- have-file-desc
- (file-obj (make-string sizeof-AEDesc 0))
- have-file-obj
- (reply (make-string sizeof-AppleEvent 0))
- event
- resultType
- transactionID
- actualSize
- (flags (encode-long-integer (+ (if tc:quick-scan 2 0) 4)))
- (one (encode-long-integer 1))
- (result
- (catch 'panic
- (throw-err (create-think-c-apple-event kAEThinkSuite kMake
- event transactionID))
-
- (throw-err (AECreateDesc typeNull "" 0 null-desc))
- (setq have-null-desc t)
- (throw-err (AECreateDesc typeLongInteger one (length one) file-desc))
- (setq have-file-desc t)
- (throw-err (CreateObjSpecifier cProjectDocument null-desc formAbsolutePosition
- file-desc 0 file-obj))
- (setq have-file-obj t)
- (throw-err (AEPutParamDesc event keyDirectObject file-obj))
- (throw-err (AEPutParamPtr event keyCompileFlags typeLongInteger
- flags (length flags)))
-
- (throw-err (AESend event reply (+ kAEQueueReply kAENeverInteract)
- kAENormalPriority 0 0 0))
-
- (setq ae-history (cons (cons transactionID
- (list (cons 'description "make")
- (cons 'handler 'tc:do-compile-reply)
- (cons 'flavor kMake)))
- ae-history))
- noErr)))
-
- (if have-null-desc (AEDisposeDesc null-desc))
- (if have-file-desc (AEDisposeDesc file-desc))
- (if have-file-obj (AEDisposeDesc file-obj))
- (if event (AEDisposeDesc event))
- result))
-
- (defun tc:compile-file-internal (file operation)
- (let* ((null-desc (make-string sizeof-AEDesc 0))
- have-null-desc
- (file-desc (make-string sizeof-AEDesc 0))
- have-file-desc
- (file-obj (make-string sizeof-AEDesc 0))
- have-file-obj
- reply
- event
- resultType
- transactionID
- actualSize
- (flags (encode-long-integer 32))
- (result
- (catch 'panic
- (throw-err (create-think-c-apple-event kAEThinkSuite operation
- event transactionID))
-
- (throw-err (AECreateDesc typeNull "" 0 null-desc))
- (setq have-null-desc t)
- (throw-err (AECreateDesc typeChar file (length file) file-desc))
- (setq have-file-desc t)
- (throw-err (CreateObjSpecifier cSourceFile null-desc formName
- file-desc 0 file-obj))
- (setq have-file-obj t)
- (throw-err (AEPutParamDesc event keyDirectObject file-obj))
-
- (if (or (equal operation kDisassemble)
- (equal operation kPreprocess))
- (throw-err
- (AEPutParamPtr event keyCompileFlags typeLongInteger flags (length flags))))
-
- (setq reply (tc:send-event event))
- (if (integerp reply) (throw 'panic reply))
- (setq ae-history
- (cons (cons transactionID
- (list
- (cons 'description
- (concat
- (cdr (assoc operation
- (list (cons kCompile "compile")
- (cons kCheckSyntax "check-syntax")
- (cons kPreprocess "preprocess")
- (cons kDisassemble "disassemble"))))
- " " file))
- (cons 'handler 'tc:do-compile-reply)
- (cons 'flavor operation)))
- ae-history))
- (tc:launch-tpm) ;;; We'll bring TPM to the front here.
- noErr)))
-
- (if have-null-desc (AEDisposeDesc null-desc))
- (if have-file-desc (AEDisposeDesc file-desc))
- (if have-file-obj (AEDisposeDesc file-obj))
- (if event (AEDisposeDesc event))
- result))
-
- (defun tc:compile-file (filename)
- (tc:compile-file-internal filename kCompile))
-
- (defun tc:check-syntax (filename)
- (tc:compile-file-internal filename kCheckSyntax))
-
- (defun tc:disassemble (filename)
- (tc:compile-file-internal filename kDisassemble))
-
- (defun tc:preprocess (filename)
- (tc:compile-file-internal filename kPreprocess))
-
- (defun tc:remove-objects ()
- (let* (event
- (null-desc (make-string sizeof-AEDesc 0))
- have-null-desc
- (objcode-desc (make-string sizeof-AEDesc 0))
- have-objcode-desc
- (objcode-obj (make-string sizeof-AEDesc 0))
- have-object-obj
- (reply (make-string sizeof-AppleEvent 0))
- actualSize
- transactionID
- (one (encode-long-integer 1))
- (result
- (catch 'panic
- (throw-err (create-think-c-apple-event kAECoreSuite kAEDelete
- event transactionID))
- (throw-err (AECreateDesc typeNull "" 0 null-desc))
- (setq have-null-desc t)
- (throw-err (AECreateDesc typeLongInteger one (length one) objcode-desc))
- (setq have-objcode-desc t)
- (throw-err (CreateObjSpecifier cObjectCode null-desc formAbsolutePosition
- objcode-desc 0 objcode-obj))
- (setq have-objcode-obj t)
- (throw-err (AEPutParamDesc event keyDirectObject objcode-obj))
-
- (throw-err (AESend event reply (+ kAEQueueReply kAENeverInteract)
- kAENormalPriority 0 0 0))
-
- (setq ae-history (cons (cons transactionID
- (list (cons 'description "remove-objects")
- (cons 'handler 'do-simple-reply)))
- ae-history))
- noErr)))
-
- (if event (AEDisposeDesc event))
- (if have-objcode-desc (AEDisposeDesc objcode-desc))
- (if have-objcode-obj (AEDisposeDesc objcode-obj))
- (if have-null-desc (AEDisposeDesc null-desc))
- result))
-